home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / AV Parser / AV Program / pict-scrolling-windows.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  4.2 KB  |  120 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;
  3. ;;; pict-scrolling-windows.lisp
  4. ;;;
  5. ;;; The class pict-scroller is a scroller view that caches its image in
  6. ;;; a pict.
  7. ;;;
  8. ;;; The class pict-scrolling-window is a scrolling window that uses a
  9. ;;; pict-scroller.
  10.  
  11. (in-package :ccl)
  12.  
  13. (require :pict-views)
  14. (require :scrollers-patch)
  15. (require :pict-scrap)
  16.  
  17. (export '(pict-scrolling-window pict-scroller scroller scroller-class)
  18.         'ccl)
  19.  
  20. (defclass pict-scroller (pict-view scroller) ())
  21.  
  22. (defmethod set-pict-cache ((view pict-scroller) pict)
  23.   (declare (ignore pict))
  24.   (call-next-method)                                     ; install the pict
  25.   (update-scroll-bars view :length t))                   ; inform scroller of field size
  26.  
  27.  
  28. (defclass pict-scrolling-window (window) 
  29.   ((scroller :accessor scroller)
  30.    (scroller-class :allocation :class
  31.                    :reader scroller-class 
  32.                    :initform 'pict-scroller)))
  33.  
  34. (defmethod initialize-instance ((self pict-scrolling-window) &key
  35.                                 (scroller-class (scroller-class self))
  36.                                 (scroll-bar-class 'scroll-bar-dialog-item)
  37.                                 h-scroll-class v-scroll-class track-thumb-p field-size)
  38.   (call-next-method)
  39.   (setf (scroller self) (make-instance
  40.                          scroller-class
  41.                          :view-container self
  42.                          :view-size (subtract-points (view-size self) #@(15 15))
  43.                          :view-position #@(0 0)
  44.                          :draw-scroller-outline nil
  45.                          :scroll-bar-class scroll-bar-class
  46.                          :h-scroll-class h-scroll-class
  47.                          :v-scroll-class v-scroll-class
  48.                          :track-thumb-p track-thumb-p
  49.                          :field-size field-size)))
  50.  
  51.  
  52. (defmethod set-view-size ((self pict-scrolling-window) h &optional v)
  53.   (declare (ignore h v))
  54.   (without-interrupts
  55.    (call-next-method)
  56.    (let* ((new-size (subtract-points (view-size self) #@(15 15))))    
  57.      (set-view-size (scroller self) new-size))))
  58.  
  59. (defmethod window-zoom-event-handler ((self pict-scrolling-window) message)
  60.   (declare (ignore message))
  61.   (let ((size (field-size (scroller self))))
  62.     (when size
  63.       (let ((h (+ 15 (point-h size)))
  64.             (v (+ 15 (point-v size))))
  65.         (set-window-zoom-size self (make-point (min h (- *screen-width* 10))
  66.                                                (min v (- *screen-height* *menubar-bottom* 10)))))))
  67.   (without-interrupts
  68.    (call-next-method)
  69.    (let* ((new-size (subtract-points (view-size self) #@(15 15))))
  70.      (set-view-size (scroller self) new-size))))
  71.  
  72. (defmethod window-close ((self pict-scrolling-window))
  73.   (call-next-method)
  74.   (view-close (scroller self)))
  75.  
  76. ;;; These methods interface with pict-scrap.
  77.  
  78. (defmethod copy ((self pict-scrolling-window))
  79.   (let ((pict (view-pict (scroller self))))
  80.     (when pict
  81.       (with-focused-view (scroller self)
  82.         (without-interrupts
  83.          (let ((topleft (rref pict Picture.picFrame.topleft))
  84.                (bottomright (rref pict Picture.picFrame.bottomright)))
  85.            (rlet ((frame :rect :topleft topleft :bottomright bottomright))
  86.              (#_ClipRect frame)
  87.              (let ((pict-copy (#_OpenPicture frame)))
  88.                (#_DrawPicture pict frame)
  89.                (#_ClosePicture)
  90.                (put-scrap :pict pict-copy t)))))))))
  91.              
  92. #|
  93. (defmethod paste ((self pict-scrolling-window))
  94.   (let ((pict (get-scrap :pict)))
  95.     (when pict
  96.       (set-pict-cache (scroller self) pict))))
  97. |#
  98.  
  99. (provide :pict-scrolling-windows)
  100.  
  101. #|
  102.  
  103. (defparameter w (make-instance 'pict-scrolling-window
  104.                                :window-type :document-with-zoom
  105.                                :track-thumb-p t))
  106.  
  107. (let ((self (scroller w)))
  108.   (with-pict-view (self 300 300)
  109.     (set-fore-color w *red-color*)
  110.     (paint-oval self 125 125 250 250)
  111.     (set-fore-color w *blue-color*)
  112.     (frame-rect self 70 70 150 150)
  113.     (erase-oval self 100 100 185 185)
  114.     (move-to self 250 150)
  115.     (set-fore-color w *yellow-color*)
  116.     (dotimes (i 50)
  117.       (line-to self 
  118.                (round (+ 150 (* 100 (cos i)))) 
  119.                (round (+ 150 (* 100 (sin i))))))))
  120. |#